home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / Widget / Wsearch.stklos < prev    next >
Encoding:
Text File  |  1995-08-25  |  3.2 KB  |  86 lines
  1. ;;;;
  2. ;;;; STk adaptation of the Tk widget demo.
  3. ;;;;
  4. ;;;; This demonstration script creates a collection of widgets that
  5. ;;;; allow you to load a file into a text widget, then perform searches
  6. ;;;; on that file.
  7. ;;;;
  8.  
  9. (define Wsearch-name   "")
  10. (define Wsearch-string "")
  11.  
  12.  
  13. (define (demo-search)
  14.   ;;
  15.   ;; Functions used by this demo
  16.   ;;
  17.   (define (load-file t file)
  18.     (text-delete t 0.0 "end")
  19.     (with-input-from-file file
  20.       (lambda ()
  21.     (do ((l (read-line) (read-line)))
  22.         ((eof-object? l))
  23.       (text-insert t "end" l)
  24.       (text-insert t "end" "\n")))))
  25.  
  26.  
  27.   (define (search t str tag)
  28.     ; Search for all instances of a given string in a text widget and
  29.     ; apply a given tag to each instance found.
  30.     (tag-remove tag 0.0 "end")
  31.     (let ((length (string-length str)))
  32.       (when (> length 0)
  33.      (let loop ((cur (text-search t str 1.0 "end")))
  34.        (when cur
  35.           (let ((last (cons (car cur) (+ (cdr cur) length))))
  36.         (tag-add tag cur last)
  37.         (loop (text-search t str last "end"))))))))
  38.  
  39.   (define (toggle t tag)
  40.     (catch (let ((bg (slot-ref tag 'background))
  41.          (fg (slot-ref tag 'foreground)))
  42.          (slot-set! tag 'foreground bg)
  43.          (slot-set! tag 'background fg)
  44.          (update)
  45.          (after t (lambda () (toggle t tag))))))
  46.  
  47.   (let* ((w   (make-demo-toplevel  "search"
  48.                    "Text Demonstration - Search and Highlight"
  49.                    ""))
  50.      (t   (make <Scroll-Text> :wrap "word" :parent w))
  51.      (tag (make <Text-tag> :parent t :foreground "IndianRed1")))
  52.  
  53.     (when (= (winfo 'depth w) 1)
  54.        (slot-set! tag 'background "white")
  55.        (slot-set! tag 'foreground "black"))         
  56.  
  57.     (let* ((f1 (make <Frame>  :parent w))
  58.        (l1 (make <Label>  :parent f1 :text "File name:" :width 13 :anchor "w"))
  59.        (e1 (make <Entry>  :parent f1 :width 40 :text-variable 'Wsearch-name))
  60.        (b1 (make <Button> :parent f1 :text "Load File" 
  61.                        :command (lambda () (load-file t Wsearch-name))))
  62.        (f2 (make <Frame>  :parent w))
  63.        (l2 (make <Label>  :parent f2 :text "Search string:" :width 13
  64.                       :anchor "w"))
  65.        (e2 (make <Entry>  :parent f2 :width 40 :text-variable 'Wsearch-string))
  66.        (b2 (make <Button> :parent f2 :text "Highlight"
  67.                      :command (lambda () 
  68.                      (search t Wsearch-string tag)))))
  69.       
  70.       (pack l1 e1 b1 :side "left" :expand #t)
  71.       (pack l2 e2 b2 :side "left" :expand #t)
  72.       (bind e1 "<Return>" (lambda () (load-file t Wsearch-name) (focus e2)))
  73.       (bind e2 "<Return>" (lambda () (search t Wsearch-string tag)))
  74.       (pack f1 f2 t :side "top")
  75.       
  76.       ;; Fill in text widget and pack it
  77.       (text-insert t "end" "This window demonstrates how to use the tagging facilities in text widgets to implement a searching mechanism.  First, type a file name in the top entry, then type <Return> or click on \"Load File\".  Then type a string in the lower entry and type <Return> or click on \"Highlight\".  This will cause all of the instances of the string to be tagged with the same tag, and it will arrange for the tag's display attributes to change to make all of the strings blink.")
  78.       (pack t :side "top" :expand #t :fill "both"))
  79.   
  80.     ;; Toggle the bg and fg colors of the search tag
  81.     (toggle 500 tag))
  82.   
  83.   ;; Reste global varaiable (for multiple executions)
  84.   (set! Wsearch-name   "")
  85.   (set! Wsearch-string ""))
  86.